home *** CD-ROM | disk | FTP | other *** search
/ Shareware Grab Bag / Shareware Grab Bag.iso / 007 / octlib.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  1985-06-03  |  7.5 KB  |  245 lines
  1.  
  2. {Some library functions to deal with octal numbers}
  3. {Function OCT converts an integer to a string representing
  4. the octal number. Example  x= oct(integer)
  5. Function STR_OCT converts a string representing an octal
  6. number to an integer. Example x = str_oct(string)}
  7.  
  8.  
  9.  
  10.  
  11. {The following procedures help in providing some machine level
  12. control by allowing a programmer to set specific bits in an
  13. integer (procedure setbit) or clear specific bits in an integer
  14. (procedure clearbit). The procedures expect two integer values
  15. to be passed. The first integer is the integer in which to
  16. manipulate the bit. This integer is treated as a variable
  17. parameter. The second integer should represent the bit number
  18. from 0 to 15 with bit 0 being the rightmost bit. A fatal error
  19. will occur if the bit number is > 15.}
  20.  
  21. procedure setbit(var number : integer ; bit_number : integer);
  22.  
  23.   const
  24.         bit_0 = $0001;
  25.         bit_1 = $0002;
  26.         bit_2 = $0004;
  27.         bit_3 = $0008;
  28.         bit_4 = $0010;
  29.         bit_5 = $0020;
  30.         bit_6 = $0040;
  31.         bit_7 = $0080;
  32.         bit_8 = $0100;
  33.         bit_9 = $0200;
  34.         bit_10 = $0400;
  35.         bit_11 = $0800;
  36.         bit_12 = $1000;
  37.         bit_13 = $2000;
  38.         bit_14 = $4000;
  39.         bit_15 = $8000;
  40.  
  41.   var
  42.      x : integer;
  43.  
  44.   begin
  45.         if bit_number >= 16 then
  46.            begin
  47.                 writeln;
  48.                 writeln('FATAL ERROR IN SETBIT PROCEDURE');
  49.                 writeln('BIT INDEX IS > 15');
  50.                 writeln('Program TERMINATING');
  51.                 halt;
  52.            end;
  53.     case bit_number of
  54.          0 : x := bit_0;
  55.          1 : x := bit_1;
  56.          2 : x := bit_2;
  57.          3 : x := bit_3;
  58.          4 : x := bit_4;
  59.          5 : x := bit_5;
  60.          6 : x := bit_6;
  61.          7 : x := bit_7;
  62.          8 : x := bit_8;
  63.          9 : x := bit_9;
  64.          10 : x := bit_10;
  65.          11 : x := bit_11;
  66.          12 : x := bit_12;
  67.          13 : x := bit_13;
  68.          14 : x := bit_14;
  69.          15 : x := bit_15;
  70.          end;
  71.     number := number and (not x);
  72.     number := number + x;
  73.  
  74. end;
  75.  
  76. procedure clearbit(var number : integer; bit_number : integer);
  77.  
  78.   var
  79.      x : integer;
  80.  
  81.     begin
  82.          if bit_number >= 16 then
  83.             begin
  84.             writeln;
  85.             writeln('FATAL ERROR IN CLEARBIT PROCEDURE');
  86.             WRITELN('BIT NUMBER > 15');
  87.             writeln('BIT NUMBER = ',bit_number);
  88.             WRITELN('PROGRAM TERMINATING');
  89.             END;
  90.          case bit_number of
  91.               0 : x := not $0001;
  92.               1 : x := not $0002;
  93.               2 : x := not $0004;
  94.               3 : x := not $0008;
  95.               4 : x := not $0010;
  96.               5 : x := not $0020;
  97.               6 : x := not $0040;
  98.               7 : x := not $0080;
  99.               8 : x := not $0100;
  100.               9 : x := not $0200;
  101.               10 : x := not $0400;
  102.               11 : x := not $0800;
  103.               12 : x := not $1000;
  104.               13 : x := not $2000;
  105.               14 : x := not $4000;
  106.               15 : x := not $8000;
  107.               end;
  108.          number := number and x;
  109. end;
  110.  
  111.  
  112. {This function provides a means of viewing an octal representation
  113. of an integer. The function expects an integer as input
  114. and returns a 6 digit string which is an octal representation
  115. of the integer.}
  116.  
  117. type
  118.     str6 = string[6];
  119.  
  120. function oct(number : integer): str6;
  121.  
  122.     var
  123.        result : string[6];
  124.        x, y, bit_mask, temp1 : integer;
  125.        subresult : char;
  126.  
  127.    begin
  128.         result := '      ';
  129.         bit_mask := $8000;
  130.         x := 0;
  131.         x := bit_mask and number;
  132.         if x = 0 then subresult := '0'
  133.         else subresult := '1';
  134.         result[1] := subresult;
  135.         bit_mask := $4000;
  136.         for y := 1 to 5 do
  137.             begin
  138.                  temp1 := 0;
  139.                  if y <> 1 then bit_mask := bit_mask div 2;
  140.                  x := bit_mask and number;
  141.                  if x <> 0 then setbit(temp1,2);
  142.                  bit_mask := bit_mask div 2;
  143.                  x := bit_mask and number;
  144.                  if x <> 0 then setbit(temp1,1);
  145.                  bit_mask := bit_mask div 2;
  146.                  x := bit_mask and number;
  147.                  if x <> 0 then setbit(temp1,0);
  148.                  case temp1 of
  149.                       0 : subresult := '0';
  150.                       1 : subresult := '1';
  151.                       2 : subresult := '2';
  152.                       3 : subresult := '3';
  153.                       4 : subresult := '4';
  154.                       5 : subresult := '5';
  155.                       6 : subresult := '6';
  156.                       7 : subresult := '7';
  157.                   else
  158.                       begin
  159.                            writeln;
  160.                            writeln('FATAL ERROR IN OCTAL FUNCTION');
  161.                            WRITELN('    PROGRAM TERMINATING      ');
  162.                            HALT;
  163.                       end;
  164.                  end;
  165.                  result[y+1] := subresult;
  166.             end;
  167.       oct := result;
  168. end;
  169.  
  170.  
  171. {function str_oct provides a means of converting a string representing}
  172. {an octal number to be converted to an integer.                       }
  173. {the function expects no more than a 6 character string and returns an}
  174. {integer result. example : y := str_oct(x)  where y is an integer and }
  175. {x is a string of no more than 6 characters representing an octal number}
  176.  
  177. type
  178.     anystring = string[6];
  179.  
  180. function str_oct(num_string : anystring ):integer;
  181.  
  182.    var
  183.       w , x , y , z ,str_oct1 ,most_flag : integer;
  184.       temp1 : char;
  185.  
  186.    begin
  187.         str_oct1 := 0;
  188.         most_flag := 0;
  189.         x := length(num_string);
  190.         if x > 6 then
  191.            begin
  192.            writeln('Fatal ERROR in Function Str_oct');
  193.            writeln('String length is > 6');
  194.            writeln('String = ',num_string);
  195.            writeln('Program Terminating');
  196.            halt;
  197.            end;
  198.         if x = 6 then
  199.            begin
  200.            temp1 := num_string[1];
  201.            case temp1 of
  202.                 '0' : most_flag := 0;
  203.                 '1' : setbit(most_flag,15);
  204.                 else
  205.                     begin
  206.                     writeln('FATAL ERROR IN STR_OCT FUNCTION');
  207.                     WRITELN('CHARACTER 6 > 1');
  208.                     WRITELN('NUM_STR = ', num_string);
  209.                     WRITELN('PROGRAM TERMINATING');
  210.                     HALT;
  211.                     END;
  212.               end;
  213.            end;
  214.  
  215.      if x = 6 then w := 2 else w := 1;
  216.  
  217.      for y := w to x do
  218.            begin
  219.            temp1 := num_string[y];
  220. {the following line is handy for debugging}
  221. {writeln('y= ',y,'  temp1 = ',temp1,'  str_oct1 = ',str_oct1);}
  222.            case temp1 of
  223.                 '0' : z := 0;
  224.                 '1' : z := 1;
  225.                 '2' : z := 2;
  226.                 '3' : z := 3;
  227.                 '4' : z := 4;
  228.                 '5' : z := 5;
  229.                 '6' : z := 6;
  230.                 '7' : z := 7;
  231.                 else
  232.                     begin
  233.                     writeln;
  234.                     writeln('FATAL ERROR IN FUNCTION STR_OCT');
  235.                     writeln('Invalid Number in string');
  236.                     writeln('STRING = ', num_string);
  237.                     writeln('Program TERMINATING');
  238.                     halt;
  239.                     end;
  240.                 end;
  241.             str_oct1 :=(str_oct1 * 8) + z;
  242.            end;
  243.        str_oct := str_oct1 or most_flag;
  244. end;
  245.